home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / lib / mathlib / libblas / src_original / zher.f < prev    next >
Encoding:
Text File  |  1994-08-02  |  6.7 KB  |  216 lines
  1. *
  2. ************************************************************************
  3. *
  4.       SUBROUTINE ZHER  ( UPLO, N, ALPHA, X, INCX, A, LDA )
  5. *     .. Scalar Arguments ..
  6.       DOUBLE PRECISION   ALPHA
  7.       INTEGER            INCX, LDA, N
  8.       CHARACTER*1        UPLO
  9. *     .. Array Arguments ..
  10.       COMPLEX*16         A( LDA, * ), X( * )
  11. *     ..
  12. *
  13. *  Purpose
  14. *  =======
  15. *
  16. *  ZHER   performs the hermitian rank 1 operation
  17. *
  18. *     A := alpha*x*conjg( x' ) + A,
  19. *
  20. *  where alpha is a real scalar, x is an n element vector and A is an
  21. *  n by n hermitian matrix.
  22. *
  23. *  Parameters
  24. *  ==========
  25. *
  26. *  UPLO   - CHARACTER*1.
  27. *           On entry, UPLO specifies whether the upper or lower
  28. *           triangular part of the array A is to be referenced as
  29. *           follows:
  30. *
  31. *              UPLO = 'U' or 'u'   Only the upper triangular part of A
  32. *                                  is to be referenced.
  33. *
  34. *              UPLO = 'L' or 'l'   Only the lower triangular part of A
  35. *                                  is to be referenced.
  36. *
  37. *           Unchanged on exit.
  38. *
  39. *  N      - INTEGER.
  40. *           On entry, N specifies the order of the matrix A.
  41. *           N must be at least zero.
  42. *           Unchanged on exit.
  43. *
  44. *  ALPHA  - DOUBLE PRECISION.
  45. *           On entry, ALPHA specifies the scalar alpha.
  46. *           Unchanged on exit.
  47. *
  48. *  X      - COMPLEX*16       array of dimension at least
  49. *           ( 1 + ( n - 1 )*abs( INCX ) ).
  50. *           Before entry, the incremented array X must contain the n
  51. *           element vector x.
  52. *           Unchanged on exit.
  53. *
  54. *  INCX   - INTEGER.
  55. *           On entry, INCX specifies the increment for the elements of
  56. *           X. INCX must not be zero.
  57. *           Unchanged on exit.
  58. *
  59. *  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
  60. *           Before entry with  UPLO = 'U' or 'u', the leading n by n
  61. *           upper triangular part of the array A must contain the upper
  62. *           triangular part of the hermitian matrix and the strictly
  63. *           lower triangular part of A is not referenced. On exit, the
  64. *           upper triangular part of the array A is overwritten by the
  65. *           upper triangular part of the updated matrix.
  66. *           Before entry with UPLO = 'L' or 'l', the leading n by n
  67. *           lower triangular part of the array A must contain the lower
  68. *           triangular part of the hermitian matrix and the strictly
  69. *           upper triangular part of A is not referenced. On exit, the
  70. *           lower triangular part of the array A is overwritten by the
  71. *           lower triangular part of the updated matrix.
  72. *           Note that the imaginary parts of the diagonal elements need
  73. *           not be set, they are assumed to be zero, and on exit they
  74. *           are set to zero.
  75. *
  76. *  LDA    - INTEGER.
  77. *           On entry, LDA specifies the first dimension of A as declared
  78. *           in the calling (sub) program. LDA must be at least
  79. *           max( 1, n ).
  80. *           Unchanged on exit.
  81. *
  82. *
  83. *  Level 2 Blas routine.
  84. *
  85. *  -- Written on 22-October-1986.
  86. *     Jack Dongarra, Argonne National Lab.
  87. *     Jeremy Du Croz, Nag Central Office.
  88. *     Sven Hammarling, Nag Central Office.
  89. *     Richard Hanson, Sandia National Labs.
  90. *
  91. *
  92. *     .. Parameters ..
  93.       COMPLEX*16         ZERO
  94.       PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
  95. *     .. Local Scalars ..
  96.       COMPLEX*16         TEMP
  97.       INTEGER            I, INFO, IX, J, JX, KX
  98. *     .. External Functions ..
  99.       LOGICAL            LSAME
  100.       EXTERNAL           LSAME
  101. *     .. External Subroutines ..
  102.       EXTERNAL           XERBLA
  103. *     .. Intrinsic Functions ..
  104.       INTRINSIC          DCONJG, MAX, DBLE
  105. *     ..
  106. *     .. Executable Statements ..
  107. *
  108. *     Test the input parameters.
  109. *
  110.       INFO = 0
  111.       IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
  112.      $         .NOT.LSAME( UPLO, 'L' )      )THEN
  113.          INFO = 1
  114.       ELSE IF( N.LT.0 )THEN
  115.          INFO = 2
  116.       ELSE IF( INCX.EQ.0 )THEN
  117.          INFO = 5
  118.       ELSE IF( LDA.LT.MAX( 1, N ) )THEN
  119.          INFO = 7
  120.       END IF
  121.       IF( INFO.NE.0 )THEN
  122.          CALL XERBLA( 'ZHER  ', INFO )
  123.          RETURN
  124.       END IF
  125. *
  126. *     Quick return if possible.
  127. *
  128.       IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) )
  129.      $   RETURN
  130. *
  131. *     Set the start point in X if the increment is not unity.
  132. *
  133.       IF( INCX.LE.0 )THEN
  134.          KX = 1 - ( N - 1 )*INCX
  135.       ELSE IF( INCX.NE.1 )THEN
  136.          KX = 1
  137.       END IF
  138. *
  139. *     Start the operations. In this version the elements of A are
  140. *     accessed sequentially with one pass through the triangular part
  141. *     of A.
  142. *
  143.       IF( LSAME( UPLO, 'U' ) )THEN
  144. *
  145. *        Form  A  when A is stored in upper triangle.
  146. *
  147.          IF( INCX.EQ.1 )THEN
  148.             DO 20, J = 1, N
  149.                IF( X( J ).NE.ZERO )THEN
  150.                   TEMP = ALPHA*DCONJG( X( J ) )
  151.                   DO 10, I = 1, J - 1
  152.                      A( I, J ) = A( I, J ) + X( I )*TEMP
  153.    10             CONTINUE
  154.                   A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP )
  155.                ELSE
  156.                   A( J, J ) = DBLE( A( J, J ) )
  157.                END IF
  158.    20       CONTINUE
  159.          ELSE
  160.             JX = KX
  161.             DO 40, J = 1, N
  162.                IF( X( JX ).NE.ZERO )THEN
  163.                   TEMP = ALPHA*DCONJG( X( JX ) )
  164.                   IX   = KX
  165.                   DO 30, I = 1, J - 1
  166.                      A( I, J ) = A( I, J ) + X( IX )*TEMP
  167.                      IX        = IX        + INCX
  168.    30             CONTINUE
  169.                   A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP )
  170.                ELSE
  171.                   A( J, J ) = DBLE( A( J, J ) )
  172.                END IF
  173.                JX = JX + INCX
  174.    40       CONTINUE
  175.          END IF
  176.       ELSE
  177. *
  178. *        Form  A  when A is stored in lower triangle.
  179. *
  180.          IF( INCX.EQ.1 )THEN
  181.             DO 60, J = 1, N
  182.                IF( X( J ).NE.ZERO )THEN
  183.                   TEMP      = ALPHA*DCONJG( X( J ) )
  184.                   A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) )
  185.                   DO 50, I = J + 1, N
  186.                      A( I, J ) = A( I, J ) + X( I )*TEMP
  187.    50             CONTINUE
  188.                ELSE
  189.                   A( J, J ) = DBLE( A( J, J ) )
  190.                END IF
  191.    60       CONTINUE
  192.          ELSE
  193.             JX = KX
  194.             DO 80, J = 1, N
  195.                IF( X( JX ).NE.ZERO )THEN
  196.                   TEMP      = ALPHA*DCONJG( X( JX ) )
  197.                   A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) )
  198.                   IX        = JX
  199.                   DO 70, I = J + 1, N
  200.                      IX        = IX        + INCX
  201.                      A( I, J ) = A( I, J ) + X( IX )*TEMP
  202.    70             CONTINUE
  203.                ELSE
  204.                   A( J, J ) = DBLE( A( J, J ) )
  205.                END IF
  206.                JX = JX + INCX
  207.    80       CONTINUE
  208.          END IF
  209.       END IF
  210. *
  211.       RETURN
  212. *
  213. *     End of ZHER  .
  214. *
  215.       END
  216.